home *** CD-ROM | disk | FTP | other *** search
/ Developer CD Series 1995 February: Tool Chest / Dev.CD Feb 95 / Dev.CD Feb 95.toast / Tool Chest / Development Tools & Languages / Dylan Related / Mindy-1.1 (sources only) / mindy-1.1 / interp / def.c < prev    next >
Encoding:
C/C++ Source or Header  |  1994-08-18  |  7.9 KB  |  273 lines  |  [TEXT/ttxt]
  1. /**********************************************************************\
  2. *
  3. *  Copyright (c) 1994  Carnegie Mellon University
  4. *  All rights reserved.
  5. *  
  6. *  Use and copying of this software and preparation of derivative
  7. *  works based on this software are permitted, including commercial
  8. *  use, provided that the following conditions are observed:
  9. *  
  10. *  1. This copyright notice must be retained in full on any copies
  11. *     and on appropriate parts of any derivative works.
  12. *  2. Documentation (paper or online) accompanying any system that
  13. *     incorporates this software, or any part of it, must acknowledge
  14. *     the contribution of the Gwydion Project at Carnegie Mellon
  15. *     University.
  16. *  
  17. *  This software is made available "as is".  Neither the authors nor
  18. *  Carnegie Mellon University make any warranty about the software,
  19. *  its performance, or its conformity to any specification.
  20. *  
  21. *  Bug reports, questions, comments, and suggestions should be sent by
  22. *  E-mail to the Internet address "gwydion-bugs@cs.cmu.edu".
  23. *
  24. ***********************************************************************
  25. *
  26. * $Header: def.c,v 1.12 94/08/18 18:42:49 wlott Exp $
  27. *
  28. * This file implements the stuff to install definitions.
  29. *
  30. \**********************************************************************/
  31.  
  32. #include "mindy.h"
  33. #include "module.h"
  34. #include "sym.h"
  35. #include "thread.h"
  36. #include "func.h"
  37. #include "list.h"
  38. #include "bool.h"
  39. #include "obj.h"
  40. #include "def.h"
  41. #include "type.h"
  42. #include "instance.h"
  43. #include "error.h"
  44. #include "class.h"
  45.  
  46. static void maybe_copy_methods(obj_t new_gf, obj_t old_gf)
  47. {
  48.     obj_t methods;
  49.  
  50.     if (old_gf == obj_Unbound)
  51.     return;
  52.     check_type(new_gf, obj_GFClass);
  53.  
  54.     methods = generic_function_methods(old_gf);
  55.  
  56.     while (methods != obj_Nil) {
  57.     add_method(new_gf, HEAD(methods));
  58.     methods = TAIL(methods);
  59.     }
  60. }
  61.  
  62.  
  63. /* Stuff to define builtin stuff. */
  64.  
  65. void define(char *name, obj_t value)
  66. {
  67.     obj_t namesym = symbol(name);
  68.     struct variable *var;
  69.  
  70.     define_variable(module_BuiltinStuff, namesym, var_Variable);
  71.     var = find_variable(module_BuiltinStuff, namesym, FALSE, TRUE);
  72.     maybe_copy_methods(value, var->value);
  73.     var->value = value;
  74.     var->function = func_Maybe;
  75. }
  76.  
  77. void define_constant(char *name, obj_t value)
  78. {
  79.     obj_t namesym = symbol(name);
  80.     struct variable *var;
  81.  
  82.     define_variable(module_BuiltinStuff, namesym, var_Constant);
  83.     var = find_variable(module_BuiltinStuff, namesym, FALSE, TRUE);
  84.     maybe_copy_methods(value, var->value);
  85.     var->value = value;
  86.     var->function = func_Maybe;
  87. }
  88.  
  89. void define_function(char *name, obj_t specializers, boolean restp,
  90.              obj_t keywords, boolean all_keys, obj_t result_type,
  91.              obj_t (*func)())
  92. {
  93.     define_constant(name,
  94.             make_builtin_method(name, specializers, restp, keywords,
  95.                     all_keys, result_type, func));
  96. }
  97.  
  98. void define_generic_function(char *name, int req_args, boolean restp,
  99.                  obj_t keys, boolean all_keys, obj_t result_types,
  100.                  obj_t more_results_type)
  101. {
  102.     obj_t namesym = symbol(name);
  103.     struct variable *var;
  104.     obj_t gf = make_generic_function(namesym, req_args, restp, keys, all_keys,
  105.                      result_types, more_results_type);
  106.  
  107.     define_variable(module_BuiltinStuff, namesym, var_GenericFunction);
  108.     var = find_variable(module_BuiltinStuff, namesym, FALSE, TRUE);
  109.     maybe_copy_methods(gf, var->value);
  110.     var->value = gf;
  111.     var->function = func_Always;
  112. }
  113.  
  114. void define_method(char *name, obj_t specializers, boolean restp,
  115.            obj_t keywords, boolean all_keys, obj_t result_type,
  116.            obj_t (*func)())
  117. {
  118.     obj_t namesym = symbol(name);
  119.     obj_t method = make_builtin_method(name, specializers, restp,
  120.                        keywords, all_keys, result_type, func);
  121.     struct variable *var;
  122.     obj_t gf;
  123.  
  124.     define_variable(module_BuiltinStuff, namesym, var_Method);
  125.     var = find_variable(module_BuiltinStuff, namesym, FALSE, TRUE);
  126.     gf = var->value;
  127.     if (gf == obj_Unbound) {
  128.     gf = make_default_generic_function(namesym, method);
  129.     var->value = gf;
  130.     var->function = func_Always;
  131.     }
  132.     add_method(gf, method);
  133. }
  134.  
  135. void define_class(char *name, obj_t value)
  136. {
  137.     obj_t namesym = symbol(name);
  138.     struct variable *var;
  139.  
  140.     define_variable(module_BuiltinStuff, namesym, var_Class);
  141.     var = find_variable(module_BuiltinStuff, namesym, FALSE, TRUE);
  142.     maybe_copy_methods(value, var->value);
  143.     var->value = value;
  144.     var->function = func_No;
  145. }
  146.  
  147.  
  148. /* Stuff to define/initialize defined stuff. */
  149.  
  150. static obj_t init_variable(obj_t var_obj, obj_t value, obj_t type)
  151. {
  152.     struct variable *var = obj_rawptr(var_obj);
  153.  
  154.     maybe_copy_methods(value, var->value);
  155.     var->value = value;
  156.     var->type = type;
  157.     if (type != obj_False && subtypep(type, obj_FunctionClass))
  158.     var->function = func_Always;
  159.     else if (instancep(value, obj_FunctionClass))
  160.     var->function = func_Yes;
  161.     else
  162.     var->function = func_No;
  163.  
  164.     return var->name;
  165. }
  166.  
  167. static obj_t defmethod(obj_t var_obj, obj_t method)
  168. {
  169.     struct variable *var = obj_rawptr(var_obj);
  170.     obj_t gf = var->value;
  171.     obj_t old;
  172.  
  173.     if (gf == obj_Unbound) {
  174.     gf = make_default_generic_function(var->name, method);
  175.     var->value = gf;
  176.     var->function = func_Always;
  177.     }
  178.     old = add_method(gf, method);
  179.  
  180.     if (old != obj_False)
  181.     error("Definition of %= clashes with %=", method, old);
  182.  
  183.     return var->name;
  184. }
  185.  
  186. static obj_t defgeneric(obj_t var_obj, obj_t signature, obj_t restp,
  187.             obj_t keywords, obj_t all_keys, obj_t result_types,
  188.             obj_t more_results_type)
  189. {
  190.     struct variable *var = obj_rawptr(var_obj);
  191.     obj_t gf = var->value;
  192.  
  193.     if (more_results_type == obj_True)
  194.     more_results_type = obj_ObjectClass;
  195.  
  196.     if (gf == obj_Unbound) {
  197.     var->value = make_generic_function(var->name, length(signature),
  198.                        restp != obj_False, keywords,
  199.                        all_keys != obj_False, result_types,
  200.                        more_results_type);
  201.     var->function = func_Always;
  202.     }
  203.     else
  204.     set_gf_signature(gf, length(signature), restp != obj_False, keywords,
  205.              all_keys != obj_False, result_types,
  206.              more_results_type);
  207.  
  208.     return var->name;
  209. }
  210.  
  211. static obj_t defclass1(obj_t class, obj_t superclasses)
  212. {
  213.     setup_class_supers(class, superclasses);
  214.  
  215.     return class;
  216. }
  217.  
  218. static obj_t defclass2(obj_t class, obj_t slots,
  219.                obj_t initargs, obj_t inheriteds)
  220. {
  221.     init_defined_class(class, slots, initargs, inheriteds);
  222.  
  223.     /* init_defined_class doesn't return */
  224.     lose("init_defined_class actually returned?\n");
  225.     return NULL;
  226. }
  227.  
  228. static obj_t defslot(obj_t getter, obj_t setter)
  229. {
  230.     struct variable *var;
  231.  
  232.     if (setter != obj_False) {
  233.     var = obj_rawptr(setter);
  234.     if (var->value == obj_Unbound)
  235.         var->value = make_generic_function(var->name, 2, FALSE, obj_False,
  236.                            FALSE, obj_Nil,
  237.                            obj_ObjectClass);
  238.     }
  239.  
  240.     var = obj_rawptr(getter);
  241.     if (var->value == obj_Unbound)
  242.     var->value = make_generic_function(var->name, 1, FALSE, obj_False,
  243.                        FALSE, obj_Nil, obj_ObjectClass);
  244.  
  245.     return var->name;
  246. }
  247.  
  248.  
  249. /* Init stuff. */
  250.  
  251. void init_def_functions(void)
  252. {
  253.     define_function("init-variable",
  254.             list3(obj_ObjectClass, obj_ObjectClass, obj_ObjectClass),
  255.             FALSE, obj_False, FALSE, obj_ObjectClass, init_variable);
  256.     define_function("%define-method", list2(obj_ObjectClass, obj_ObjectClass),
  257.             FALSE, obj_False, FALSE, obj_ObjectClass, defmethod);
  258.     define_function("%define-generic",
  259.             listn(7, obj_ObjectClass, obj_ObjectClass, obj_ObjectClass,
  260.               obj_ObjectClass, obj_ObjectClass, obj_ObjectClass,
  261.               obj_ObjectClass),
  262.             FALSE, obj_Nil, FALSE, obj_ObjectClass, defgeneric);
  263.     define_function("%define-class-1",
  264.             list2(obj_ObjectClass, obj_ObjectClass),
  265.             FALSE, obj_False, FALSE, obj_ObjectClass, defclass1);
  266.     define_function("%define-class-2",
  267.             listn(4, obj_ObjectClass, obj_ObjectClass,
  268.               obj_ObjectClass, obj_ObjectClass),
  269.             FALSE, obj_False, FALSE, obj_ObjectClass, defclass2);
  270.     define_function("%define-slot", list2(obj_ObjectClass, obj_ObjectClass),
  271.             FALSE, obj_False, FALSE, obj_ObjectClass, defslot);
  272. }
  273.